﻿<%
'**************************************************************
' Software Name: EasyesESYS
' Web: http://www.Easyes.com.cn
'**************************************************************
'**************************************************
'函数名：Checkstr
'作  用：过滤非法的SQL字符
'参  数：Str-----要过滤的字符
'返回值：过滤后的字符
'**************************************************
Function Checkstr(Str)
 If Isnull(Str) Then
  CheckStr = ""
  Exit Function 
 End If
 Str = Replace(Str,Chr(0),"", 1, -1, 1)
 Str = Replace(Str, """", "&quot;", 1, -1, 1)
 Str = Replace(Str,"<","&lt;", 1, -1, 1)
 Str = Replace(Str,">","&gt;", 1, -1, 1) 
 Str = Replace(Str, "script", "&#115;cript", 1, -1, 0)
 Str = Replace(Str, "SCRIPT", "&#083;CRIPT", 1, -1, 0)
 Str = Replace(Str, "Script", "&#083;cript", 1, -1, 0)
 Str = Replace(Str, "script", "&#083;cript", 1, -1, 1)
 Str = Replace(Str, "object", "&#111;bject", 1, -1, 0)
 Str = Replace(Str, "OBJECT", "&#079;BJECT", 1, -1, 0)
 Str = Replace(Str, "Object", "&#079;bject", 1, -1, 0)
 Str = Replace(Str, "object", "&#079;bject", 1, -1, 1)
 Str = Replace(Str, "applet", "&#097;pplet", 1, -1, 0)
 Str = Replace(Str, "APPLET", "&#065;PPLET", 1, -1, 0)
 Str = Replace(Str, "Applet", "&#065;pplet", 1, -1, 0)
 Str = Replace(Str, "applet", "&#065;pplet", 1, -1, 1)
 Str = Replace(Str, "[", "&#091;")
 Str = Replace(Str, "]", "&#093;")
 Str = Replace(Str, """", "", 1, -1, 1)
 Str = Replace(Str, "=", "&#061;", 1, -1, 1)
 Str = Replace(Str, "'", "''", 1, -1, 1)
 Str = Replace(Str, "select", "sel&#101;ct", 1, -1, 1)
 Str = Replace(Str, "execute", "&#101xecute", 1, -1, 1)
 Str = Replace(Str, "exec", "&#101xec", 1, -1, 1)
 Str = Replace(Str, "join", "jo&#105;n", 1, -1, 1)
 Str = Replace(Str, "union", "un&#105;on", 1, -1, 1)
 Str = Replace(Str, "where", "wh&#101;re", 1, -1, 1)
 Str = Replace(Str, "insert", "ins&#101;rt", 1, -1, 1)
 Str = Replace(Str, "delete", "del&#101;te", 1, -1, 1)
 Str = Replace(Str, "update", "up&#100;ate", 1, -1, 1)
 Str = Replace(Str, "like", "lik&#101;", 1, -1, 1)
 Str = Replace(Str, "drop", "dro&#112;", 1, -1, 1)
 Str = Replace(Str, "create", "cr&#101;ate", 1, -1, 1)
 Str = Replace(Str, "rename", "ren&#097;me", 1, -1, 1)
 Str = Replace(Str, "count", "co&#117;nt", 1, -1, 1)
 Str = Replace(Str, "chr", "c&#104;r", 1, -1, 1)
 Str = Replace(Str, "mid", "m&#105;d", 1, -1, 1)
 Str = Replace(Str, "truncate", "trunc&#097;te", 1, -1, 1)
 Str = Replace(Str, "nchar", "nch&#097;r", 1, -1, 1)
 Str = Replace(Str, "char", "ch&#097;r", 1, -1, 1)
 Str = Replace(Str, "alter", "alt&#101;r", 1, -1, 1)
 Str = Replace(Str, "cast", "ca&#115;t", 1, -1, 1)
 Str = Replace(Str, "exists", "e&#120;ists", 1, -1, 1)
 Str = Replace(Str,Chr(13),"<br>", 1, -1, 1)
 CheckStr = Replace(Str,"'","''", 1, -1, 1)
End Function
'***************************************************
'函数名：HTMLEncode1
'参 数：str(要处理的字符串)
'返回值：返回处理后的字符串
'***************************************************
'//转换双引号到单引号（Admin_LabelStyle.asp）
Function HTMLEncode1(str)
   if not isnull(str) then
    str = Replace(str, CHR(34), "")  '双引号
    str = Replace(str, "'", "")  '单引号
    str = Replace(str, "<", "{") 
    str = Replace(str, ">", "}") 
    HTMLEncode1 = str
 end if
End function
'//转换硬回车为其它特殊任务(下载模板--下载地址处理专用)
Function HTMLEncode2(str)
	if not isnull(str) then
		str = Replace(str,CHR(13),"@@@")  '转换回车符
    	HTMLEncode2 = str
	End if
End function
'***************************************************
'函数名：HTMLDecode
'作 用：过滤HTML语句
'参 数：strHTML(要过滤的字符串)
'返回值：过滤后的内容
'***************************************************
Function HTMLDecode(strHTML) 
	Dim objRegExp, Match, Matches 
	Set objRegExp = New Regexp 
	objRegExp.IgnoreCase = True 
	objRegExp.Global = True 
'取闭合的<> 
	objRegExp.Pattern = "<.+?>" 
'进行匹配 
	Set Matches = objRegExp.Execute(strHTML) 
' 遍历匹配集合，并替换掉匹配的项目 
	For Each Match in Matches 
		strHtml=Replace(strHTML,Match.Value,"") 
	Next 
	htmlDecode=strHTML 
	Set objRegExp = Nothing 
End Function
'***************************************************
'函数名：jencode
'作  用：日文假名编码
'参  数：jencode ----日文字符
'返回值：日文编码后的字符
'***************************************************
Function jencode(byVal iStr)
If isnull(iStr) or isEmpty(iStr) Then
   jencode=""
   Exit function
End if
Dim F,i,E
   E=array("Jn0;","Jn1;","Jn2;","Jn3;","Jn4;","Jn5;","Jn6;","Jn7;","Jn8;","Jn9;","Jn10;","Jn11;","Jn12;","Jn13;","Jn14;","Jn15;","Jn16;","Jn17;","Jn18;","Jn19;","Jn20;","Jn21;","Jn22;","Jn23;","Jn24;","Jn25;")
   F=array(chrw(12468),chrw(12460),chrw(12462),chrw(12464),_
     chrw(12466),chrw(12470),chrw(12472),chrw(12474),_
     chrw(12485),chrw(12487),chrw(12489),chrw(12509),_
     chrw(12505),chrw(12503),chrw(12499),chrw(12497),_
     chrw(12532),chrw(12508),chrw(12506),chrw(12502),_
     chrw(12500),chrw(12496),chrw(12482),chrw(12480),_
     chrw(12478),chrw(12476))
   jencode=iStr
   for i=0 to 25
   jencode=replace(jencode,F(i),E(i))
   next
End Function
'***************************************************
'函数名：juncode
'作  用：日文假名解码
'参  数：juncode ----日文字符
'返回值：字符解码后的日文字
'***************************************************
Function juncode(byVal iStr)
if isnull(iStr) or isEmpty(iStr) then
   juncode=""
   Exit function
end if
Dim F,i,E
	E=array("Jn0;","Jn1;","Jn2;","Jn3;","Jn4;","Jn5;","Jn6;","Jn7;","Jn8;","Jn9;","Jn10;","Jn11;","Jn12;","Jn13;","Jn14;","Jn15;","Jn16;","Jn17;","Jn18;","Jn19;","Jn20;","Jn21;","Jn22;","Jn23;","Jn24;","Jn25;")
	F=array(chrw(12468),chrw(12460),chrw(12462),chrw(12464),_
    	chrw(12466),chrw(12470),chrw(12472),chrw(12474),_
    	chrw(12485),chrw(12487),chrw(12489),chrw(12509),_
    	chrw(12505),chrw(12503),chrw(12499),chrw(12497),_
    	chrw(12532),chrw(12508),chrw(12506),chrw(12502),_
    	chrw(12500),chrw(12496),chrw(12482),chrw(12480),_
    	chrw(12478),chrw(12476))
   juncode=iStr
for i=0 to 25
   juncode=replace(juncode,E(i),F(i))
next
End Function
'***************************************************
'函数名：IsObjInstalled
'作  用：检查组件是否已经安装,远程保存图片使用
'参  数：strClassString ----组件名
'返回值：True  ----已经安装
'        False ----没有安装
'***************************************************
Function IsObjInstalled(strClassString)
On Error Resume Next
IsObjInstalled = False
Err = 0
Dim xTestObj
Set xTestObj = Server.CreateObject(strClassString)
If 0 = Err Then IsObjInstalled = True
Set xTestObj = Nothing
Err = 0
End Function

'****************************************************
'过程名：WriteErrMsg
'作  用：显示错误提示信息
'参  数：无
'****************************************************
Sub WriteErrMsg(errmsg)
dim strErr
dim ComeUrl
	ComeUrl=Request.ServerVariables("HTTP_REFERER")
	strErr=strErr & "<script>alert('【操作失败！错误提示】\n\n" & errmsg &"');window.location.href='javascript:history.go(-1);';</script>"
	response.write strErr
	Response.end
End sub

'****************************************************
'过程名：WriteSuccessMsg
'作  用：显示成功提示信息
'参  数：无
'****************************************************
Sub WriteSuccessMsg(SuccessMsg)
dim strSuccess
dim ComeUrl
	ComeUrl=Request.ServerVariables("HTTP_REFERER")
	strSuccess=strSuccess & "<script>alert('【操作成功！信息提示】\n\n" & SuccessMsg &"');window.location.href='" & ComeUrl &"';</script>"
	response.write strSuccess
	Response.end
End sub

'**************************************************
'函数名：AdminPurview
'函数：读取等级
'返回：字符串，（例：超级用户）
'**************************************************
Function AdminPurview()
Select Case Session("purview")
Case 1
	response.write "超级用户"
Case 2
	response.write "高级管理员"
Case 3
	response.write "信息录入员"
End select
End Function

'****************************************************
'过程名：FileCopy
'作  用：备份数据库
'参  数：file1,File2
'****************************************************
function FileCopy(byref file1,byref File2,fAct)
Dim FileSpec1
	FileSpec1=Server.MapPath(file1)
Dim FileSpec2
	FileSpec2=Server.MapPath(File2)
	Dim fso 
	Set fso = CreateObject(UpFileFSO) 
		fso.CopyFile filespec1,filespec2,True
	IF fAct=2 Then
		fso.DeleteFile filespec1
	End IF
	Set fso = Nothing 
	If Err.number<>0 Then 
		FileCopy = "对不起，你要复制的文件不在!"
	  Else
		FileCopy = True 
	End IF
End function 

'****************************************************
'过程名：Admin_HtmlEditor
'作  用：编辑器修改
'参  数：Sqlrs,Content,ShowType
'****************************************************
Sub Admin_HtmlEditor()
If Editor=1 Then
	Response.write"<iframe ID=""oContent___Frame"" src=""Fckeditor/editor/fckeditor.html?InstanceName=Content&amp;Toolbar=Default"" width=""100%"" height=""400"" frameborder=""0"" scrolling=""no""></iframe>"
ElseIf Editor=2 Then
	Response.write"<iframe ID=""oContent___Frame"" src=""Fckeditor/editor/fckeditor.html?InstanceName=Content&amp;Toolbar=Basic"" width=""100%"" height=""400"" frameborder=""0"" scrolling=""no""></iframe>"
End if
End Sub

'****************************************************
'过程名：ajax
'作  用：表单提交验资 class="required-validate"
'参  数：
Sub ajax()
	Response.write "<script src=""Config/AjaxEngine/prototype.js"" type=""text/javascript""></script>"&chr(13)
	Response.write "<script src=""Config/AjaxEngine/unittest.js"" type=""text/javascript""></script>"&chr(13)
	Response.write "<script src=""Config/AjaxEngine/validation_cn.js"" type=""text/javascript""></script>"&chr(13)
	Response.write "<link href=""Config/AjaxEngine/style_min.css"" rel=""stylesheet"" type=""text/css"">"&chr(13)
End Sub

'***************************************************
'作 用：替换字符串中的远程文件为本地文件并保存远程文件
'参 数：
'     sHTML            : 要替换的字符串
'     sSaveFilePath    : 保存文件的路径
'     sFileExt         : 执行替换的扩展名
'***************************************************
Function ReplaceRemoteUrl(sHTML,sSaveFilePath,sFileExt)
    Dim s_Content
    s_Content = sHTML
    If IsObjInstalled("Microsoft.XMLHTTP") = False then
        ReplaceRemoteUrl = s_Content
        Exit Function
    End If
    Dim re,RemoteFile, RemoteFileUrl,SaveFileName,SaveFileType,arrSaveFileName,fso
    Set re = new RegExp
    re.IgnoreCase = True
    re.Global = True
    re.Pattern = "((http|https|ftp|rtsp|mms):(\/\/|\\\\){1}((\w)+[.]){1,}(net|com|cn|org|cc|tv|[0-9]{1,3})(\S*\/)((\S)+[.]{1}(" & sFileExt & ")))"
    Set RemoteFile = re.Execute(s_Content)  's_Content 内容集合
    
'建立目录的路径
    Dim dtNow,SavePath
    SavePath= Year(dtNow) & Right("0" & Month(dtNow), 2) '日期
    sSaveFilePath=sSaveFilePath & "/" & SavePath  '文件路径

'For语句开始
For Each RemoteFileurl in RemoteFile   'RemoteFileurl 图片绝对路径

'建立目录;检查某一目录是否存在,如不存在则建立相应的文件夹
    Dim Folderpath
	Folderpath=Server.MapPath(sSaveFilePath)
	Set fso = Server.CreateObject(UpFileFSO)
	If fso.FolderExists(sSaveFilePath)=False then
			CreateDIR(folderpath)
		If fso.GetFolder(folderpath)="" Then
        	fso.CreateFolder(folderpath)
  		end if
	End if

'文件格式化和获取文件的扩展名
	RemoteFileurl = RemoteFileurl.Value   '文件的绝对路径	
	arrSaveFileName = Split(RemoteFileurl, ".")
	SaveFileType = arrSaveFileName(UBound(arrSaveFileName))   '扩展名
'原创文件重命名
        Dim ranNum,FileArray
		dtNow = Now()	
        ranNum = Int(900 * Rnd) + 100
        SaveFileName = Year(dtNow) & Right("0" & Month(dtNow), 2) & Right("0" & Day(dtNow), 2) & Right("0" & Hour(dtNow), 2) & Right("0" & Minute(dtNow), 2) & Right("0" & Second(dtNow), 2) & ranNum & "." & SaveFileType
		FileArray=FileArray & sSaveFilePath &"/"& SaveFileName & "|"    '取得本地每个图片的路径并以“|”分开 赋值给变量“FileArray”
        SaveFileName = sSaveFilePath &"/"& SaveFileName    '取得本地每个图片的路径,赋值给变量“SaveFileName”
        Call SaveRemoteFile(SaveFileName,RemoteFileurl)  
        s_Content = Replace(s_Content,RemoteFileurl,SaveFileName)
    Next
    ReplaceRemoteUrl = s_Content
    Set RemoteFile = Nothing
	Set Fso = Nothing
End Function

'***************************************************
'函数名：SaveRemoteFile
'作  用：保存远程的文件到本地
'参  数：LocalFileName ------ 本地文件名
'        RemoteFileUrl ------ 远程文件URL
'返回值：True ----- 保存成功
'        False ----- 保存失败
'***************************************************
Function SaveRemoteFile(LocalFileName,RemoteFileUrl)
    On Error Resume Next
    Dim Ads, Retrieval, GetRemoteData
    Set Retrieval = Server.CreateObject("Microsoft.XMLHTTP")
    With Retrieval
        .open "Get", RemoteFileUrl, False, "", ""
        .Send
        GetRemoteData = .ResponseBody
    End With
    If Err.Number <> 0 Then
        Err.Clear
        SaveRemoteFile = False
        Exit Function
    End If
    Set Retrieval = Nothing
    Set Ads = Server.CreateObject("Adodb.Stream")
    With Ads
        .Type = 1
        .open
        .Write GetRemoteData
        .SaveToFile Server.MapPath(LocalFileName), 2
        .Cancel
        .Close
    End With
    Set Ads = Nothing
    If Err.Number <> 0 Then
        Err.Clear
        SaveRemoteFile = False
    Else
        SaveRemoteFile = True
    End If
End Function

'***************************************************
'函数名：CreateDIR
'作  用：建立目录的程序，如果有多级目录，则一级一级的创建
'参  数：LocalPath ------ 文件路径
'返回值：True ----- 保存成功
'***************************************************
function CreateDIR(LocalPath)
On Error Resume Next  '错误忽略
Dim patharr,pathtmp,cpath,FileObject,I
	LocalPath = replace(LocalPath,"\","/")
    Set FileObject = server.createobject(UpFileFSO)
    Patharr = split(LocalPath,"/")
    For i = 0 to ubound(patharr)
		If i=0 then pathtmp=patharr(0) & "/" else pathtmp = pathtmp & patharr(i) & "/"
		Cpath = left(pathtmp,len(pathtmp)-1)
		If not FileObject.FolderExists(cpath) then FileObject.CreateFolder cpath
    Next
		Set FileObject = nothing
	If Err.Number<>0 Then
		CreateDIR=False
		Err.Clear
	Else
		CreateDIR=True
	End If  
End function

'***************************************************
'过程名：RegExpExecute
'作 用：读取内容中的图片
'参 数：strng ------ 包含图片的内容
'返回值：RegExpExecute----- 以“|”分割图片列表
'***************************************************
Function RegExpExecute(strng) 
	Dim regEx, Match, Matches '建立变量。 
	Set regEx = New RegExp '建立正则表达式。 
	regEx.Pattern = "(src=)('|"&CHR(34)&"| )?(.[^'|\s|"&CHR(34)&"]*)(\.)(jpg|gif|png|bmp)('|"&CHR(34)&"|\s|>)?" '设置模式。 
	regEx.IgnoreCase = true '设置是否区分字符大小写。 
	regEx.Global = True '设置全局可用性。 
	Set Matches = regEx.Execute(strng) '执行搜索。 
	For Each Match in Matches '遍历匹配集合。 
		values=values&Match.SubMatches(2)&Match.SubMatches(3)&Match.SubMatches(4)&"|" 
	Next
	Dim values
	RegExpExecute = values 
End Function 

'***************************************************
'过程名：GetImg
'作 用：取得文章中第一张图片
'参 数：retstr  ----包含的图片列表以“|”分割
'返回值：GetImg ----- 以“|”分割图片列表的第一张
'***************************************************
Function GetImg(retstr)
Dim Imglist,strpath,Imgone
If retstr<>"" Then
	Imglist=split(retstr,"|")
	Imgone=replace(Imglist(1),strpath,"")
	GetImg=Imgone
Else
	GetImg=""
End If
End function

'**************************************************
'函数名：DeleteFile
'作  用：删除文件和目录功能
'参  数：sPathFile  ----文件路径
'**************************************************
'//删除文件
Function DeleteFile(FilePath)
    '若是链接跳转型资料直接退出
    If Not IsLocalFilePath(FilePath) Then
        Exit Function
    End If
    On Error Resume Next  '错误忽略
   	Dim FSO
   	Set FSO = Server.CreateObject(UpFileFSO)
	FilePath = Server.MapPath(FilePath)
    If Fso.FileExists(FilePath) Then
        Fso.DeleteFile(FilePath)
    End If
    Set Fso=Nothing
End Function

'//删除目录
Function DeleteFolder(Byval Dirpath)
    '若是链接跳转型资料直接退出
    If Not IsLocalFilePath(Dirpath) Then
        Exit Function
    End If
   On Error Resume Next  '错误忽略
   Dim FSO
   Set FSO = Server.CreateObject(UpFileFSO)
   FSO.Deletefolder Server.Mappath(Dirpath)
   If Err Then Err.Clear: Deletefolder = False Else Deletefolder = True
End Function

'***********************************************
'//文件路径是否为本地路径
Function IsLocalFilePath(FilePath)
    If Trim(FilePath)="" Or IsNull(FilePath) Then
        IsLocalFilePath = False
        Exit Function
    End If

    Dim regEx
    Set regEx = New RegExp
    regEx.IgnoreCase = True
    regEx.Pattern = "^[/|\\]"
    '若是链接跳转型资料直接退出
    IsLocalFilePath = regEx.Test(FilePath)
    Set regEx = Nothing
End Function
%> 